home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / copymove.swg / 0006_Copy File #6.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-05-28  |  4.1 KB  |  167 lines
  1. {$A+,B-,D-,E+,F-,I+,L-,N-,O-,R+,S+,V-}
  2. {$M 16384,65536,655360}
  3.  
  4. Program scopy;
  5.  
  6. Uses
  7.   Dos,
  8.   tpDos,
  9.   sundry,
  10.   Strings;
  11.  
  12. Type
  13.   buffer_Type = Array[0..65519] of Byte;
  14.   buffptr     = ^buffer_Type;
  15.  
  16. Var
  17.   f1,f2       : File;
  18.   fname1,
  19.   fname2,
  20.   NewFName,
  21.   OldDir      : PathStr;
  22.   SRec        : SearchRec;
  23.   errorcode   : Integer;
  24.   buffer      : buffptr;
  25. Const
  26.   MakeNewName : Boolean = False;
  27.   FilesCopied : Word = 0;
  28.   MaxHeapSize = 65520;
  29.  
  30. Function IOCheck(stop : Boolean; msg : String): Boolean;
  31.   Var
  32.     error : Integer;
  33.   begin
  34.     error := Ioresult;
  35.     IOCheck := (error = 0);
  36.     if error <> 0 then begin
  37.       Writeln(msg);
  38.       if stop then begin
  39.         ChDir(OldDir);
  40.         halt(error);
  41.       end;
  42.     end;
  43.   end;
  44.  
  45. Procedure Initialise;
  46.   Var
  47.     temp  : String;
  48.     dir   : DirStr;
  49.     name  : NameStr;
  50.     ext   : ExtStr;
  51.   begin
  52.     if MaxAvail < MaxHeapSize then begin
  53.       Writeln('Insufficient memory');
  54.       halt;
  55.     end
  56.     else
  57.       new(buffer);
  58.     {I-} GetDir(0,OldDir); {$I+} if IOCheck(True,'') then;
  59.     Case ParamCount of
  60.       0: begin
  61.            Writeln('No parameters provided');
  62.            halt;
  63.          end;
  64.       1: begin
  65.            TempStr := ParamStr(1);
  66.            if not ParsePath(TempStr,fname1,fname2) then begin
  67.              Writeln('Invalid parameter');
  68.              halt;
  69.            end;
  70.            {$I-} ChDir(fname2); {$I+} if IOCheck(True,'') then;
  71.          end;
  72.       2: begin
  73.            TempStr := ParamStr(1);
  74.            if not ParsePath(TempStr,fname1,fname2) then begin
  75.              Writeln('Invalid parameter');
  76.              halt;
  77.            end
  78.            else
  79.              {$I-} ChDir(fname2); {$I+} if IOCheck(True,'') then;
  80.  
  81.            TempStr := ParamStr(2);
  82.            if not ParsePath(TempStr,fname2,temp) then begin
  83.              Writeln('Invalid parameter');
  84.              halt;
  85.            end;
  86.            FSplit(fname2,dir,name,ext);
  87.            if length(name) <> 0 then
  88.              MakeNewName := True;
  89.          end;
  90.     else begin
  91.            Writeln('too many parameters');
  92.            halt;
  93.          end;
  94.     end; { Case }
  95.   end; { Initialise }
  96.  
  97. Procedure CopyFiles;
  98.   Var
  99.     result : Word;
  100.  
  101.   Function MakeNewFileName(fn : String): String;
  102.     Var
  103.       temp  : String;
  104.       dir   : DirStr;
  105.       name  : NameStr;
  106.       ext   : ExtStr;
  107.       numb  : Word;
  108.     begin
  109.       numb := 0;
  110.       FSplit(fn,dir,name,ext);
  111.       Repeat
  112.         inc(numb);
  113.         if numb > 255 then begin
  114.           Writeln('Invalid File name');
  115.           halt(255);
  116.         end;
  117.         ext := copy(Numb2Hex(numb),2,3);
  118.         temp := dir + name + ext;
  119.         Writeln(temp);
  120.       Until not ExistFile(temp);
  121.       MakeNewFileName := temp;
  122.     end; { MakeNewFileName }
  123.  
  124.  
  125.   begin
  126.     FindFirst(fname1,AnyFile,Srec);
  127.     While Doserror = 0 do begin
  128.       if (SRec.attr and $19) = 0 then begin
  129.         if MakeNewName then
  130.           NewFName := fname2
  131.         else
  132.           NewFName := SRec.name;
  133.         if ExistFile(NewFName) then
  134.           NewFName := MakeNewFileName(NewFName);
  135.         {$I-}
  136.         Writeln('Copying ',SRec.name,' > ',NewFName);
  137.         assign(f1,SRec.name);
  138.         reset(f1,1);
  139.         if { =1= } IOCheck(False,'1. Cannot copy '+fname1) then begin
  140.           assign(f2,fname2);
  141.           reWrite(f2,1);
  142.           if IOCheck(False,'2. Cannot copy '+SRec.name) then
  143.             Repeat
  144.               BlockRead(f1,buffer^,MaxHeapSize);
  145.               if IOCheck(False,'3. Cannot copy '+SRec.name) then
  146.                 result := 0
  147.               else begin
  148.                 BlockWrite(f2,buffer^,result);
  149.                 if IOCheck(False,'4. Cannot copy '+NewFName) then
  150.                   result := 0;
  151.               end;
  152.             Until result < MaxHeapSize;
  153.           close(f1); close(f2);
  154.           if IOCheck(False,'Error While copying '+SRec.name) then;
  155.         end; { =1= }
  156.       end;  { if SRec.attr }
  157.       FindNext(Srec);
  158.     end; { While Doserror = 0 }
  159.   end; { CopyFiles }
  160.  
  161. begin
  162.   Initialise;
  163.   CopyFiles;
  164.   ChDir(OldDir);
  165. end.
  166.  
  167.